#!/usr/bin/perl
use strict;
use warnings;
use Language::Prolog::Yaswi qw(:load :query);
use Language::Prolog::Sugar
  functors => [qw(text link parent child tag url target only)],
  vars     => [qw(X A B C D E)];
use YAML;

my $config_file = shift || 'config';
our %params = %{YAML::LoadFile($config_file)};

our $min_accuracy  = $params{min_accuracy};
our $max_variable  = 'A';
$max_variable++ for 1..($params{max_depth});

my $hash_root = {};
my %tokens = %{YAML::LoadFile($params{tokens_file})};
foreach my $token (keys %tokens) {
    my @sub_tokens = split /\s+/, $token;
    push @sub_tokens, 'DATA';
    my $code = '$hash_root->{\''.join("'}{'", @sub_tokens)."'} = '$token';"; 
    eval $code;
    die "$@" if $@;
}
#unlink $params{tokens_file};

our $root = &hash_to_array($hash_root->{'link:a'});
$hash_root = undef;

our @total_pos;
our @total_neg;

our @labels = @{YAML::LoadFile($params{labels_file})};
for (0..$#labels) {
    $labels[$_] eq '+' 
        ? push(@total_pos, $_)
        : push(@total_neg, $_);
}
#unlink $params{labels_file};

our $min_pos_cover = $params{min_pos_cover} * @total_pos;

print "Loading facts...\n";
swi_consult $params{facts_file};
print "Done!\n\n";
#unlink $params{facts_file};

print "Start inductive logic programming...\n\n";

our @frontiers = ['link(X, A)', 'A', \@total_pos, \@total_neg, ['A', $root, 0 ] ];

our @results;

while ( @frontiers ) {
    my $frontier = shift @frontiers;
	&print_rule($frontier);
    my ($rule, $last_variable, $pos_ref, $neg_ref, @entries) = @$frontier;
    for my $entry_index (0..$#entries) {
        my ($variable, $ref, $index, @children) = @{$entries[$entry_index]};
        print "\n  $variable";
        my $token = &get_token($ref, $index);
        for my $new_index (($index + 1)..$#{$ref}) {
            my $new_ref = $ref->[$new_index];
            my $new_token = &get_token($ref, $new_index);
            next if $token =~ /^only$/ and $new_token =~ /^text:/ or $token =~ /^text:/ and $new_token =~ /^only$/;
            next if $token =~ /^parent/ and $new_token =~ /^parent/;
            print "\n    $new_token";
            my ($new_rule, $new_last_variable, @new_pos, @new_neg);
            my @new_entries = @entries;
            my @new_children = @children;
            my ($pred, $constant) = split /:/, $new_token;
            if ($pred !~ /^(?:parent|child)$/) {
                $new_last_variable = $last_variable;
                if (defined $constant) {
                    $new_rule = "$rule, $pred($variable, $constant)";
                }
                else {
                    $new_rule = "$rule, $pred($variable)";
                    if ($pred eq 'target') {
                        $new_rule .= ", not(link(X, $variable))";
                    }
                }
            }
            else {
                ($new_last_variable = $last_variable)++;
                next if $new_last_variable gt $max_variable;
                my $literal = "$pred($variable, $new_last_variable, $constant)";
                if ($pred eq 'parent') {
                    push @new_entries, [$new_last_variable, $new_ref, 0, $variable];
                }
                elsif ($pred eq 'child') {
                    for my $child (@children) {
                        $literal .= ", $new_last_variable \\== $child";
                    }
                    push @new_children, $new_last_variable;
                    push @new_entries, [$new_last_variable, $new_ref, 0];
                }
                else {
                    die "unknown predicate: $pred\n";
                }
                $new_rule  = "$rule, $literal";
            }
            for (@$pos_ref) {
                push @new_pos, $_ if &cover($new_rule, $_);
            }
            next if @new_pos < $min_pos_cover;
            for (@$neg_ref) {
                push @new_neg, $_ if &cover($new_rule, $_);
            }
            next if $pred =~ /^(?:url|text)$/ and !&significant(scalar(@$pos_ref), scalar(@$neg_ref), scalar(@new_pos), scalar(@new_neg));
            $new_entries[$entry_index] = [$variable, $ref, $new_index, @new_children];
            my $new_rule_ref = [$new_rule, $new_last_variable, \@new_pos, \@new_neg, @new_entries];
            my $new_accuracy = @new_pos / (@new_pos + @new_neg);
            printf " (p: %d n: %d a: %.2f%%)", scalar(@new_pos), scalar(@new_neg), 100 * $new_accuracy;
            if ($new_accuracy > $min_accuracy and is_valid_rule($new_rule)) {
                push @results, $new_rule_ref;
                print " R";
            }
            else {
                push @frontiers, $new_rule_ref;
                print " F";
            }
        }
    }
    print "\n\n";
}

@results = sort { scalar(@{$b->[2]}) <=> scalar(@{$a->[2]}) } @results;

for my $first_index (0..$#results) {
    my $this_result = $results[$first_index];
    next unless $this_result;
    my $this_ref = [sort { $a <=> $b } (@{$this_result->[2]}, @{$this_result->[3]}) ];
    for my $second_index (($first_index+1)..$#results) {
        my $that_result = $results[$second_index];
        next unless $that_result;
        my $that_ref = [sort { $a <=> $b } (@{$that_result->[2]}, @{$that_result->[3]})];
        if (&suppressed($that_ref, $this_ref)) {
            $results[$second_index] = undef;
        }
    }
}
@results = grep { defined $_ } @results;
@results = @results[0..49] unless $#results < 50;

our @total_covers;
our %token_seen;

for my $result (@results) {
    $total_covers[$_] = 1 for (@{$result->[2]}, @{$result->[3]});
    for (@$result[4..$#{$result}]) {
        my $token = $_->[1][$_->[2]];
        $token = $token->[0] if $_->[2] != 0;
        $token_seen{$token} = 1;
    }
}

open DICT, "> $params{dict_file}" or die "$!";
print DICT 'link:a', "\n";
print DICT $_, "\n" for keys %token_seen;
close DICT;

my ($total_cover_cnt, $total_pos_cover_cnt) = (0, 0);
$total_cover_cnt = grep { defined $_ } @total_covers;
for (@total_pos) {
    $total_pos_cover_cnt++ if defined $total_covers[$_];
}

open RESULT, "> $params{rules_file}" or die "$!";
print RESULT ":- dynamic text/2, link/2, parent/3, child/3, tag/2, url/2, target/1, only/1.\n";
print RESULT ":- style_check(-singleton).\n";
for my $index (0..$#results) {
    my $result = $results[$index];
    my ($rule, undef, $pos_ref, $neg_ref) = @$result;
    printf RESULT "rule$index(X) :- %s.\n%%pos: %d neg: %d a: %.2f%%\n\n", $rule, scalar(@$pos_ref), scalar(@$neg_ref), 100 * @$pos_ref / (@$pos_ref + @$neg_ref);
}

my $N = @total_pos + @total_neg;

print RESULT sprintf "%%Total coverage ratio: %.2f%% (%d/%d)\n", 100 * $total_cover_cnt / $N, $total_cover_cnt, $N;
print RESULT sprintf "%%Total pos coverage ratio: %.2f%% (%d/%d)\n", 100 * $total_pos_cover_cnt / @total_pos, $total_pos_cover_cnt, scalar(@total_pos);
close RESULT;

print sprintf "%%Total coverage ratio: %.2f%% (%d/%d)\n", 100 * $total_cover_cnt / $N, $total_cover_cnt, $N;
print sprintf "%%Total pos coverage ratio: %.2f%% (%d/%d)\n", 100 * $total_pos_cover_cnt / @total_pos, $total_pos_cover_cnt, scalar(@total_pos);

print "All done!\n\n";

sub cover {
    my ($query, $index) = @_;
    (my $new_query = $query) =~ s/X/p$index/g;
    swi_eval($new_query);
}

sub significant {
    my ( $pos_old, $neg_old, $pos_new, $neg_new ) = @_;
    my $pos_ratio_new = $pos_new / ( $pos_new + $neg_new );
    my $pos_ratio_old = $pos_old / ( $pos_old + $neg_old );
    my $p_value       =
      ( $pos_new & $pos_old ) ? log( $pos_ratio_new / $pos_ratio_old ) : 0;
    my $n_value =
      ( $neg_new & $neg_old )
      ? log( ( 1 - $pos_ratio_new ) / ( 1 - $pos_ratio_old ) )
      : 0;
    my $sig = 2 * $pos_new * $p_value + 2 * $neg_new * $n_value;
    $sig > 6.64;
}

sub print_rule {
    my $rule_ref = shift;
	my ($rule, $last_variable, $pos_ref, $neg_ref) = @$rule_ref;
	print sprintf("target(X) :- %s. p: %d n: %d a: %.2f%%\n", $rule, scalar(@$pos_ref), scalar(@$neg_ref), 100 * @$pos_ref / (@$pos_ref + @$neg_ref));
}

sub suppressed {
    my ($this_ref, $that_ref) = @_;
    my ($this_index, $that_index) = (0, 0);
    my $overlap_count = 0;
    while ($this_index < @$this_ref and $that_index < @$that_ref) {
        my ($this_elem, $that_elem) = ($this_ref->[$this_index], $that_ref->[$that_index]);
        if ($this_elem < $that_elem) {
            $this_index++;
        } elsif ($this_elem > $that_elem) {
            $that_index++;
        } else {
            $overlap_count++;
            $this_index++;
            $that_index++;
        }
    }
    $overlap_count > $params{cover_ratio} * @$this_ref;
}

sub hash_to_array {
    my $hash_ref = shift;
    my %orders = (
        url => 1,
        text => 2,
        only => 3,
        target => 4,
        parent => 5,
        child  => 6,
    );
    my $label = $hash_ref->{'DATA'};
    my $array_ref = [$label];
    my @keys = sort {
                        my ($pred_a) = split /:/, $a;
                        my ($pred_b) = split /:/, $b;
                        if ($pred_a ne $pred_b) {
                            return $orders{$pred_a} <=> $orders{$pred_b};
                        }
                        return $a cmp $b; } grep { $_ ne 'DATA' } keys %$hash_ref;
    for my $key (@keys) {
        my $value = $hash_ref->{$key};
        push @$array_ref, &hash_to_array($value);
    }
    return $array_ref;
}

sub get_token {
    my ($ref, $index) = @_;
    my $token;
    if ($index == 0) {
        $token = $ref->[$index];
    }
    else {
        $token = $ref->[$index][0];
    }
    return (split /\s+/, $token)[-1];
}

sub is_valid_rule {
    shift =~ /, (?:text|url|target)\(/;
}

